home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / combin.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  13.3 KB  |  344 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (defun null-wrappers-method-function (&rest args)
  31.   ;; Function returned when get-method-function passed no wrappers for
  32.   ;; caching.  I'm not exactly sure why get-method-function gets called
  33.   ;; with null wrappers when a generic function is first created, but
  34.   ;; they do.  However, the method-function returned never seemed to
  35.   ;; get called, so to save a bunch of unneed closure-generation
  36.   ;; and other muckity-muck, this function is just returned instead.
  37.   (error "Internal PCL error:  Calling method-function created by
  38.           get-method-function with wrappers NIL.  Called with args: ~S"
  39.          args))
  40.  
  41. (defun get-method-function (method &optional method-alist wrappers)
  42.   (or (cadr (assq method method-alist))
  43.       (if wrappers
  44.       (method-function-for-caching method wrappers)
  45.       (or (method-optimized-function method)
  46.               #'null-wrappers-method-function))))
  47.  
  48. (defun make-effective-method-function (generic-function form &optional 
  49.                        method-alist wrappers)
  50.   (funcall-function (make-effective-method-function1 generic-function form)
  51.                 method-alist wrappers))
  52.  
  53. (defun make-effective-method-function1 (generic-function form)
  54.   (if (and (listp form)
  55.        (eq (car form) 'call-method)
  56.        (method-p (cadr form))
  57.        (or (every #'method-p (caddr form))
  58.            (not (method-needs-next-methods-p (cadr form)))))
  59.       (make-effective-method-function-simple generic-function form)
  60.       ;;
  61.       ;; We have some sort of `real' effective method.  Go off and get a
  62.       ;; compiled function for it.  Most of the real hair here is done by
  63.       ;; the GET-FUNCTION mechanism.
  64.       ;; 
  65.       (make-effective-method-function-internal generic-function form)))
  66.  
  67. (defun make-effective-method-function-simple (generic-function form)
  68.   ;;
  69.   ;; The effective method is just a call to call-method.  This opens up
  70.   ;; the possibility of just using the method function of the method as
  71.   ;; as the effective method function.
  72.   ;;
  73.   ;; But we have to be careful.  If that method function will ask for
  74.   ;; the next methods we have to provide them.  We do not look to see
  75.   ;; if there are next methods, we look at whether the method function
  76.   ;; asks about them.  If it does, we must tell it whether there are
  77.   ;; or aren't to prevent the leaky next methods bug.
  78.   ;; 
  79.   (let ((method (cadr form)))
  80.     (if (not (method-needs-next-methods-p method))
  81.     #'(lambda (method-alist wrappers)
  82.         (get-method-function method method-alist wrappers))
  83.     (let* ((arg-info (gf-arg-info generic-function))
  84.            (metatypes (arg-info-metatypes arg-info))
  85.            (applyp (arg-info-applyp arg-info))
  86.            (next-methods (caddr form)))
  87.       (declare (type boolean applyp))
  88.       (multiple-value-bind (cfunction constants)
  89.           (get-function1
  90.            `(lambda ,(make-dfun-lambda-list metatypes applyp)
  91.           (let ((*next-methods* .next-methods.))
  92.             ,(make-dfun-call metatypes applyp '.method.)))
  93.            #'default-test-converter ;This could be optimized by making
  94.                     ;the interface from here to the
  95.                     ;walker more clear so that the
  96.                     ;form wouldn't get walked at all.
  97.            #'(lambda (form)
  98.            (if (memq form '(.next-methods. .method.))
  99.                (values form (list form))
  100.                form))
  101.            #'(lambda (form)
  102.            (cond ((eq form '.next-methods.)
  103.               (list (cons '.meth-list. next-methods)))
  104.              ((eq form '.method.)
  105.               (list (cons '.meth. method))))))
  106.         #'(lambda (method-alist wrappers)
  107.         (flet ((fix-meth (meth)
  108.              (get-method-function meth method-alist wrappers)))
  109.           (apply-function cfunction
  110.                   (mapcar #'(lambda (constant)
  111.                           (cond ((atom constant)
  112.                              constant)
  113.                             ((eq (car constant) '.meth.)
  114.                              (fix-meth (cdr constant)))
  115.                             ((eq (car constant) '.meth-list.)
  116.                              (mapcar #'fix-meth (cdr constant)))
  117.                             (t constant)))
  118.                       constants)))))))))
  119.  
  120. (declaim (type list *global-effective-method-gensyms*))
  121. (defvar *global-effective-method-gensyms* ())
  122. (defvar *rebound-effective-method-gensyms*)
  123.  
  124. (defun get-effective-method-gensym ()
  125.   (or (pop *rebound-effective-method-gensyms*)
  126.       (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" 
  127.                  (length *global-effective-method-gensyms*))
  128.              "PCL")))
  129.     (setq *global-effective-method-gensyms*
  130.           (append *global-effective-method-gensyms* (list new)))
  131.     new)))
  132.  
  133. (let ((*rebound-effective-method-gensyms* ()))
  134.   (dotimes (i 10) (get-effective-method-gensym)))
  135.  
  136. (defun make-effective-method-function-internal (generic-function effective-method)
  137.   (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
  138.      (arg-info (gf-arg-info generic-function))
  139.      (metatypes (arg-info-metatypes arg-info))
  140.      (applyp (arg-info-applyp arg-info)))
  141.     (declare (type boolean applyp))
  142.     (labels ((test-converter (form)
  143.            (if (and (consp form) (eq (car form) 'call-method))
  144.            (if (caddr form)
  145.                '.call-method-with-next.
  146.                '.call-method-without-next.)
  147.            (default-test-converter form)))
  148.          (code-converter (form)
  149.            (if (and (consp form) (eq (car form) 'call-method))
  150.            ;;
  151.            ;; We have a `call' to CALL-METHOD.  There may or may not be next
  152.            ;; methods and the two cases are a little different.  It controls
  153.            ;; how many gensyms we will generate.
  154.            ;;
  155.            (let ((gensyms
  156.               (if (caddr form)
  157.                   (list (get-effective-method-gensym)
  158.                     (get-effective-method-gensym))
  159.                   (list (get-effective-method-gensym)))))
  160.              (values `(let ((*next-methods* ,(cadr gensyms)))
  161.                    ,(make-dfun-call metatypes applyp (car gensyms)))
  162.                  gensyms))
  163.            (default-code-converter form)))
  164.          (constant-converter (form)
  165.            (if (and (consp form) (eq (car form) 'call-method))
  166.            (if (caddr form)
  167.                (list (cons '.meth. (check-for-make-method (cadr form)))
  168.                  (cons '.meth-list.
  169.                    (mapcar #'check-for-make-method (caddr form))))
  170.                (list (cons '.meth. (check-for-make-method (cadr form)))))
  171.            (default-constant-converter form)))
  172.          (check-for-make-method (effective-method)
  173.            (cond ((method-p effective-method)
  174.               effective-method)
  175.              ((and (listp effective-method)
  176.                (eq (car effective-method) 'make-method))
  177.               (make-effective-method-function1
  178.                generic-function
  179.                (make-progn (cadr effective-method))))
  180.              (t
  181.               (error "Effective-method form is malformed.")))))
  182.       (multiple-value-bind (cfunction constants)
  183.       (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp)
  184.                ,effective-method)
  185.              #'test-converter
  186.              #'code-converter
  187.              #'constant-converter)
  188.     #'(lambda (method-alist wrappers)
  189.         (flet ((fix-meth (meth)
  190.              (if (method-p meth)
  191.              (get-method-function meth method-alist wrappers)
  192.              (funcall-function meth method-alist wrappers))))
  193.           (apply-function cfunction
  194.                   (mapcar #'(lambda (constant)
  195.                       (cond ((atom constant)
  196.                          constant)
  197.                         ((eq (car constant) '.meth.)
  198.                          (fix-meth (cdr constant)))
  199.                         ((eq (car constant) '.meth-list.)
  200.                          (mapcar #'fix-meth (cdr constant)))
  201.                         (t constant)))
  202.                       constants))))))))
  203.  
  204.  
  205.  
  206. (defvar *invalid-method-error*
  207.     #'(lambda (&rest args)
  208.         (declare (ignore args))
  209.         (error
  210.           "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
  211.                of a method combination function (inside the body of~%~
  212.                DEFINE-METHOD-COMBINATION or a method on the generic~%~
  213.                function COMPUTE-EFFECTIVE-METHOD).")))
  214.  
  215. (defvar *method-combination-error*
  216.     #'(lambda (&rest args)
  217.         (declare (ignore args))
  218.         (error
  219.           "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
  220.                of a method combination function (inside the body of~%~
  221.                DEFINE-METHOD-COMBINATION or a method on the generic~%~
  222.                function COMPUTE-EFFECTIVE-METHOD).")))
  223.  
  224. ;(defmethod compute-effective-method :around        ;issue with magic
  225. ;       ((generic-function generic-function)     ;generic functions
  226. ;        (method-combination method-combination)
  227. ;        applicable-methods)
  228. ;  (declare (ignore applicable-methods))
  229. ;  (flet ((real-invalid-method-error (method format-string &rest args)
  230. ;       (declare (ignore method))
  231. ;       (apply #'error format-string args))
  232. ;     (real-method-combination-error (format-string &rest args)
  233. ;       (apply #'error format-string args)))
  234. ;    (let ((*invalid-method-error* #'real-invalid-method-error)
  235. ;      (*method-combination-error* #'real-method-combination-error))
  236. ;      (call-next-method))))
  237.  
  238. (defun invalid-method-error (&rest args)
  239.   (declare (arglist method format-string &rest format-arguments))
  240.   (apply *invalid-method-error* args))
  241.  
  242. (defun method-combination-error (&rest args)
  243.   (declare (arglist format-string &rest format-arguments))
  244.   (apply *method-combination-error* args))
  245.  
  246.  
  247.  
  248. ;;;
  249. ;;; The STANDARD method combination type.  This is coded by hand (rather than
  250. ;;; with define-method-combination) for bootstrapping and efficiency reasons.
  251. ;;; Note that the definition of the find-method-combination-method appears in
  252. ;;; the file defcombin.lisp, this is because EQL methods can't appear in the
  253. ;;; bootstrap.
  254. ;;;
  255. ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
  256. ;;; classes has to appear here for this reason.  This code must conform to
  257. ;;; the code in the file defcombin, look there for more details.
  258. ;;;
  259.  
  260. (defclass method-combination (metaobject) ()
  261.   (:predicate-name method-combination-p))
  262.  
  263.  
  264. (mapc
  265.  #'proclaim-incompatible-superclasses
  266.  '(;; superclass metaobject
  267.    (class eql-specializer class-eq-specializer method method-combination
  268.     generic-function slot-definition)
  269.    ))
  270.  
  271. (defclass standard-method-combination
  272.       (documentation-mixin definition-source-mixin method-combination)
  273.      ((type          :reader method-combination-type
  274.                  :initarg :type)
  275.       (options       :reader method-combination-options
  276.                  :initarg :options)))
  277.  
  278. (defmethod print-object ((mc method-combination) stream)
  279.   (printing-random-thing (mc stream)
  280.     (format stream
  281.         "Method-Combination ~S ~S"
  282.         (method-combination-type mc)
  283.         (method-combination-options mc))))
  284.  
  285. (eval-when (load eval)
  286.   (setq *standard-method-combination*
  287.     (make-instance 'standard-method-combination
  288.                :type 'standard
  289.                :documentation "The standard method combination."
  290.                :options ())))
  291.  
  292. ;This definition appears in defcombin.lisp.
  293. ;
  294. ;(defmethod find-method-combination ((generic-function generic-function)
  295. ;                     (type (eql 'standard))
  296. ;                     options)
  297. ;  (when options
  298. ;    (method-combination-error
  299. ;      "The method combination type STANDARD accepts no options."))
  300. ;  *standard-method-combination*)
  301.  
  302. (defun make-call-methods (methods)
  303.   (mapcar #'(lambda (method) `(call-method ,method ())) methods))
  304.  
  305. (defmethod compute-effective-method ((generic-function generic-function)
  306.                      (combin standard-method-combination)
  307.                      applicable-methods)
  308.   (let ((before ())
  309.     (primary ())
  310.     (after ())
  311.     (around ()))
  312.     (dolist (m applicable-methods)
  313.       (let ((qualifiers (method-qualifiers m)))
  314.     (cond ((memq ':before qualifiers)  (push m before))
  315.           ((memq ':after  qualifiers)  (push m after))
  316.           ((memq ':around  qualifiers) (push m around))
  317.           (t
  318.            (push m primary)))))
  319.     (setq before  (reverse before)
  320.       after   (reverse after)
  321.       primary (reverse primary)
  322.       around  (reverse around))
  323.     (cond ((null primary)
  324.        `(error "No primary method for the generic function ~S." ',generic-function))
  325.       ((and (null before) (null after) (null around))
  326.        ;;
  327.        ;; By returning a single call-method `form' here we enable an important
  328.        ;; implementation-specific optimization.
  329.        ;; 
  330.        `(call-method ,(first primary) ,(rest primary)))
  331.       (t
  332.        (let ((main-effective-method
  333.            (if (or before after)
  334.                `(multiple-value-prog1
  335.               (progn ,@(make-call-methods before)
  336.                  (call-method ,(first primary) ,(rest primary)))
  337.               ,@(make-call-methods (reverse after)))
  338.                `(call-method ,(first primary) ,(rest primary)))))
  339.          (if around
  340.          `(call-method ,(first around)
  341.                    (,@(rest around) (make-method ,main-effective-method)))
  342.          main-effective-method))))))
  343.  
  344.